Visual Basic Graphics Programming (2nd Edition)

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH12 / SRC / LIGHT2.FRM (.txt) < prev next >

Wrap

Visual Basic Form | 1997-01-08 | 18.0 KB | 582 lines

VERSION 4.00 Begin VB.Form LightForm Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Light2" ClientHeight = 6075 ClientLeft = 1335 ClientTop = 630 ClientWidth = 6030 BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H80000008& Height = 6765 KeyPreview = -1 'True Left = 1275 LinkTopic = "Form1" ScaleHeight = 6075 ScaleWidth = 6030 Top = 0 Width = 6150 Begin VB.TextBox KaText BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 285 Left = 2040 TabIndex = 10 Text = "0.30" Top = 5760 Width = 855 End Begin VB.TextBox KdText BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 285 Left = 480 TabIndex = 8 Text = "0.65" Top = 5760 Width = 855 End Begin VB.TextBox PhiText BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 285 Left = 3600 TabIndex = 6 Text = "0.1571" Top = 5400 Width = 855 End Begin VB.TextBox ThetaText BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 285 Left = 2040 TabIndex = 4 Text = "1.8850" Top = 5400 Width = 855 End Begin VB.TextBox RText BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 285 Left = 480 TabIndex = 2 Text = "20.0000" Top = 5400 Width = 855 End Begin VB.PictureBox Pict AutoRedraw = -1 'True BackColor = &H00FFFF80& BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 5295 Left = 0 Picture = "Light2.frx":0000 ScaleHeight = -14 ScaleLeft = -7 ScaleMode = 0 'User ScaleTop = 7 ScaleWidth = 15.926 TabIndex = 0 Top = 0 Width = 6015 End Begin VB.Label Label1 Caption = "k" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 255 Index = 5 Left = 1680 TabIndex = 12 Top = 5760 Width = 135 End Begin VB.Label Label1 Caption = "a" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 255 Index = 4 Left = 1800 TabIndex = 11 Top = 5880 Width = 135 End Begin VB.Label Label1 Caption = "d" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 255 Index = 3 Left = 240 TabIndex = 9 Top = 5880 Width = 135 End Begin MSComDlg.CommonDialog LoadDialog Left = 4560 Top = 5160 _Version = 65536 _ExtentX = 847 _ExtentY = 847 _StockProps = 0 CancelError = -1 'True End Begin VB.Label Label1 Caption = "k" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 255 Index = 7 Left = 120 TabIndex = 7 Top = 5760 Width = 135 End Begin VB.Label Label1 Caption = "Phi" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 255 Index = 2 Left = 3240 TabIndex = 5 Top = 5400 Width = 375 End Begin VB.Label Label1 Caption = "Theta" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 255 Index = 1 Left = 1440 TabIndex = 3 Top = 5400 Width = 495 End Begin VB.Label Label1 Caption = "R" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 255 Index = 0 Left = 240 TabIndex = 1 Top = 5400 Width = 255 End Begin VB.Menu mnuFile Caption = "&File" Begin VB.Menu mnuFileLoad Caption = "&Load..." Shortcut = ^L End Begin VB.Menu mnuFileSep Caption = "-" End Begin VB.Menu mnuFileExit Caption = "E&xit" End End Attribute VB_Name = "LightForm" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Dim SysPalSize As Integer Dim NumStaticColors As Integer Dim StaticColor1 As Integer Dim StaticColor2 As Integer Dim syspal(0 To 255) As PALETTEENTRY ' Location of viewing eye. Dim EyeR As Single Dim EyeTheta As Single Dim EyePhi As Single Const Dtheta = PI / 20 Const Dphi = PI / 20 Const dr = 1 ' Location of focus point. Const FocusX = 0# Const FocusY = 0# Const FocusZ = 0# Dim Projector(1 To 4, 1 To 4) As Single Dim ThePicture As ObjPicture Dim ShowingParameters As Boolean ' ******************************************************* ' Rotate the points in the cube and draw the cube. ' ******************************************************* Private Sub DrawData(pic As Object) Dim X As Single Dim Y As Single Dim z As Single Dim old_draw As Integer Dim old_fill As Integer Dim t1(1 To 4, 1 To 4) As Single Dim t2(1 To 4, 1 To 4) As Single Dim T12(1 To 4, 1 To 4) As Single Dim T123(1 To 4, 1 To 4) As Single Dim pt As Point3D MousePointer = vbHourglass ' Get constants for the surfaces. LightKd = CSng(KdText.Text) LightKa = CSng(KaText.Text) ' Prevent overflow errors when drawing lines ' too far out of bounds. On Error Resume Next ' Cull backfaces. ThePicture.Culled = False m3SphericalToCartesian EyeR, EyeTheta, EyePhi, X, Y, z ThePicture.Cull X, Y, z ' Clip faces behind the center of projection. ThePicture.ClipEye EyeR ' Transform coordinates into pixels. m3Scale t1, _ Pict.ScaleX(1, Pict.ScaleMode, vbPixels), _ Pict.ScaleY(1, Pict.ScaleMode, vbPixels), _ 1 m3Translate t2, _ -Pict.ScaleX(Pict.ScaleLeft, Pict.ScaleMode, vbPixels), _ -Pict.ScaleY(Pict.ScaleTop, Pict.ScaleMode, vbPixels), _ 0 m3MatMultiply T12, t1, t2 m3MatMultiplyFull T123, Projector, T12 ' Transform the points. ThePicture.ApplyFull T123 ' Clear the screen. We must do this before ' selecting the pen and brush since Cls resets ' the pen and brush to default values. pic.Cls ' Prepare to fill polygons. old_draw = pic.DrawStyle old_fill = pic.FillStyle pic.DrawStyle = vbInvisible pic.FillStyle = vbFSSolid ' Display the data. ThePicture.DrawShaded pic, EyeR pic.Refresh ' Restore the old draw and fill styles. pic.DrawStyle = old_draw pic.FillStyle = old_fill ' Display the viewing parameters. ShowViewingParameters MousePointer = vbDefault End Sub Sub ShowViewingParameters() ShowingParameters = True RText.Text = Format$(EyeR, "0.0000") ThetaText.Text = Format$(EyeTheta, "0.0000") PhiText.Text = Format$(EyePhi, "0.0000") RText.Refresh ThetaText.Refresh PhiText.Refresh ShowingParameters = False End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Select Case KeyCode Case vbKeyLeft EyeTheta = EyeTheta - Dtheta Case vbKeyRight EyeTheta = EyeTheta + Dtheta Case vbKeyUp EyePhi = EyePhi - Dphi Case vbKeyDown EyePhi = EyePhi + Dphi Case Else Exit Sub End Select m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0 DrawData Pict End Sub Private Sub Form_KeyPress(KeyAscii As Integer) Select Case KeyAscii Case Asc("+") EyeR = EyeR + dr Case Asc("-") EyeR = EyeR - dr Case Else Exit Sub End Select m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0 DrawData Pict End Sub Private Sub Form_Load() ' Make sure the screen supports palettes. If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then Beep MsgBox "This monitor does not support palettes.", _ vbCritical End End If ' Get system palette size and # static colors. SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE) NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED) StaticColor1 = NumStaticColors \ 2 - 1 StaticColor2 = SysPalSize - NumStaticColors \ 2 ' Fill the picture's palette with grays. MatchGrayPalette Pict Pict.Cls ' Initialize the eye position. EyeR = 20 EyeTheta = PI * 0.2 EyePhi = PI * 0.05 ' Initialize the projection transformation. m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0 End Sub ' *********************************************** ' Load the control's palette so the non-static ' colors are grays. Map the logical palette to ' match the system palette. Convert the image to ' use the non-static grays. ' Leave new system palette entries in SysPal(). ' *********************************************** Sub MatchGrayPalette(pic As Control) Dim origpal(0 To 255) As PALETTEENTRY Dim wid As Long Dim hgt As Long Dim bytes() As Byte Dim i As Integer Dim bm As BITMAP Dim hbm As Integer Dim status As Long Dim X As Integer Dim Y As Integer Dim gray As Single Dim dgray As Single Dim c As Integer Dim clr As Integer Dim logpal As Long ' Make sure pic has the foreground palette. pic.ZOrder status = RealizePalette(pic.hdc) DoEvents ' Get the system palette entries. status = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, origpal(0)) ' Get the image pixels. hbm = pic.Image status = GetObject(hbm, BITMAP_SIZE, bm) wid = bm.bmWidthBytes hgt = bm.bmHeight ReDim bytes(1 To wid, 1 To hgt) status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1)) ' Make the logical palette as big as possible. logpal = pic.Picture.hPal If ResizePalette(logpal, SysPalSize) = 0 Then Beep MsgBox "Error resizing logical palette.", _ vbExclamation Exit Sub End If ' Blank the non-static colors. For i = 0 To StaticColor1 syspal(i) = origpal(i) Next i For i = StaticColor1 + 1 To StaticColor2 - 1 With syspal(i) .peRed = 0 .peGreen = 0 .peBlue = 0 .peFlags = PC_NOCOLLAPSE End With Next i For i = StaticColor2 To 255 syspal(i) = origpal(i) Next i status = SetPaletteEntries(logpal, 0, SysPalSize, syspal(0)) ' Insert the non-static grays. gray = 0 dgray = 255 / (StaticColor2 - StaticColor1 - 2) For i = StaticColor1 + 1 To StaticColor2 - 1 c = gray gray = gray + dgray With syspal(i) .peRed = c .peGreen = c .peBlue = c End With Next i status = SetPaletteEntries(logpal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, syspal(StaticColor1 + 1)) ' Realize the gray palette. status = RealizePalette(pic.hdc) pic.Refresh End Sub Private Sub mnuFileExit_Click() Unload Me End Sub Private Sub mnuFileLoad_Click() Dim fname As String Dim filenum As Integer Dim txt As String Dim xmin As Single Dim ymin As Single Dim xmax As Single Dim ymax As Single ' Allow the user to pick a file. On Error Resume Next LoadDialog.filename = "*.APF" LoadDialog.ShowOpen LoadDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly If Err.Number = cdlCancel Then Unload LoadDialog Exit Sub ElseIf Err.Number <> 0 Then Unload LoadDialog Beep MsgBox "Error selecting file.", , vbExclamation Exit Sub End If On Error GoTo 0 fname = LoadDialog.filename LoadDialog.InitDir = Left$(fname, Len(fname) _ - Len(LoadDialog.FileTitle) - 1) ' Clear the picture. Set ThePicture = Nothing ' Open the file. filenum = FreeFile Open fname For Input As #filenum ' Make sure it's an Object Picture File. Input #filenum, txt If txt <> "3D APF PICTURE" Then Close filenum Caption = "Light2" Beep MsgBox "Error reading file """ & fname & """.", , vbExclamation Exit Sub End If ' Read the picture. Set ThePicture = New ObjPicture ThePicture.FileInput filenum ' Close the file. Close filenum Caption = "Light2 [" & LoadDialog.FileTitle & "]" ' Refresh the display. DrawData Pict End Sub Private Sub PhiText_Change() If ShowingParameters Then Exit Sub EyePhi = CSng(PhiText.Text) m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0 DrawData Pict End Sub Private Sub RText_Change() If ShowingParameters Then Exit Sub EyeR = CSng(RText.Text) m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0 DrawData Pict End Sub Private Sub ThetaText_Change() If ShowingParameters Then Exit Sub EyeTheta = CSng(ThetaText.Text) m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0 DrawData Pict End Sub